; portable "case sensitiveness":
; (setf (readtable-case *readtable*) :invert)

; sbcl cd: (sb-posix:chdir "/dir")
; clisp cd: (ext:cd "/dir")

; =================================================
; analyzer event description
(defmacro analyzer-event (context action args))

; =================================================
; type description
(defstruct type-desc
  (id nil :type symbol))

; =================================================
; make void typedesc
(defvar *void-typedesc* (make-type-desc :id 'void))
(defun make-void-type-desc ()
  *void-typedesc*)

; =================================================
; an element of the argument list
(defstruct arg-list-elem
  (name nil :type (or nil symbol))
  (typedesc nil :type type-desc))

; =================================================
; function decl
(defstruct func-decl
  (return-type nil :type type-desc)
  (args nil :type cons)
  (body nil :type (or null cons)))

; =================================================
; context structure
(defstruct analyzer-context
  (marks nil :type hash-table)
  (types nil :type hash-table)
  (funcs nil :type hash-table)
  (forwards nil :type hash-table))

; =================================================
; default context structure constructor
(defun make-empty-analyzer-context ()
  (make-analyzer-context
    :marks (make-hash-table)
    :funcs (make-hash-table)
    :types (make-hash-table)
    :forwards (make-hash-table)))

; =================================================
; register mark
(defun accept-forwarded-mark (mark-decl context)
  (unless (= 1 (length mark-decl))
    (error "mark declaration shall contain only one symbol"))
  (let ((mark (car mark-decl))
        (marks-table (analyzer-context-marks context)))
    (unless (symbolp mark)
      (error "mark is not a symbol"))
    (unless (null (gethash mark marks-table))
      (error "mark has already been defined"))
    (setf (gethash mark marks-table) 1)
    (format t "defining mark: ~a~%" mark)))

; =================================================
; register type
(defun accept-forwarded-type (type-decl context)
  (unless (= 1 (length type-decl))
    (error "type declaration shall contain only one symbol"))
  (let ((tp (car type-decl))
        (types-table (analyzer-context-types context)))
    ; type shall be a symbol
    (check-type tp symbol)
    ; redefinitions prohibited
    (unless (null (gethash tp types-table))
      (error "type has already been defined"))
    (setf (gethash tp types-table) 1)
    (format t "defining type: ~a~%" tp)))

; =================================================
; retrieves element at the given position or signals error
;(defmacro t-nth (src-list arg-pos expected-type)
;  (if (listp expected-type)
;  `(let ((arg (nth src-list))
;         (if )))))
(defmacro checked-nth (pos src-list expected-type)
  `(let ((result (nth ,pos ,src-list)))
     (unless (typep result ,expected-type)
       (error "unexpected type"))
     result))

; =================================================
; converts argument to the arg structure
(defun convert-argument (arg)
  (cond
    ; argument specified by only a type
    ((symbolp arg) (make-arg-list-elem
                     :typedesc (make-type-desc :id arg)))
    ; argument specified by either type and associated name
    ((listp arg) (if (= 1 (length arg))
                   ; (typespec)
                   (make-arg-list-elem
                     :typedesc (make-type-desc :id (car arg)))
                   ; (typespec argument)
                   (make-arg-list-elem
                     :typedesc (make-type-desc
                                 :id (checked-nth 0 arg 'symbol))
                     :name (checked-nth 1 arg 'symbol))))
    ; unknown argument type
    (t (error "argument list element is of unknown type"))))


; =================================================
; convert to arguments list
; access to the type identifier is as follows:
;   (type-desc-id (arg-list-elem-typedesc (car a)))
(defun accept-arglist (arg-list)
  (loop for arg in arg-list
        collect (convert-argument arg)))

; ================================================= register function
(defun accept-func (func-decl context forwarded)
  (check-type forwarded boolean)
  (unless (funcall (if forwarded '> '=) 2 (length func-decl))
    (error "func declaration expects function name and arguments list"))
  (let ((funcs-table (analyzer-context-funcs context))
        (func-name (checked-nth 0 func-decl 'symbol))
        (f (make-func-decl
            :return-type (make-void-type-desc)
            :args (accept-arglist (checked-nth 1 func-decl 'cons))
            :body (if forwarded
                      (cddr func-decl)
                      nil))))
    (setf (gethash func-name funcs-table) f)))

; =================================================
; handle forwarded tokens
(defun accept-forwards (f context)
  (dolist (fwd-decl f)
    (check-type fwd-decl cons)
    (let ((fwd-type (car fwd-decl))
          (fwd-expr (cdr fwd-decl)))
      (cond
        ((eq fwd-type 'mark) (accept-forwarded-mark fwd-expr context))
        ((eq fwd-type 'type) (accept-forwarded-type fwd-expr context))
        ((eq fwd-type 'func) (accept-func fwd-expr context nil))
        (t (error "unknown token"))
        ))))

; =================================================
; accepts function
(defun accept-function (f context)
  (accept-func f context forwarded))

; =================================================
; accepts expession and dispatches it's content
(defun accept-expr (expr context)
  (check-type expr cons)
  (let ((func-token (car expr)))
    (cond
      ((eq func-token 'forwards) (accept-forwards (cdr expr) context))
      (t (format t "unknown "))))
  (format t "expr token = ~a~%" (car expr)))

; =================================================
; analyzing file contents
(defun analyze1 (file-name)
  (let ((context (make-empty-analyzer-context)))
    (with-open-file (in-stream file-name
                               :direction :input
                               :if-does-not-exist :error)
      (loop for expr = (read in-stream nil)
            until (null expr)
            do (progn
                 ; (format t "~a~%" expr)
                 (accept-expr expr context))))
    context))

